home *** CD-ROM | disk | FTP | other *** search
/ Games of Daze / Infomagic - Games of Daze (Summer 1995) (Disc 1 of 2).iso / x2ftp / msdos / source / dptools / charedtv.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1994-10-05  |  14.7 KB  |  630 lines
  1. {
  2.   programme de changement de font de caractere sous turbo vision
  3.  d'apres des source trouve dans SWAG
  4.      de MICHAEL HOENIE - Intelec Pascal Moderator.
  5.    programme realise par
  6.     charles vidal
  7.     pour toutes suggestions
  8.     email : vidal@amertume.ufr-info-p7.ibp.fr
  9.  
  10.  }
  11. program Edit_char_TV;
  12. uses Dos,Memory, Crt,MsgBox, Objects, Drivers,Views,Menus, Dialogs, App,InpLong,stddlg;
  13.  
  14. const
  15.   cmAbout = 1000;
  16.   cmLoad = 1001;
  17.   cmsave = 1002;
  18.   cmModifier = 1003;
  19.   cmInverse = 1004;
  20.   cmFill =1005;
  21.   cmClear=1006;
  22.   cmEnscar=1007;
  23.   cmflip =1008;
  24.   cmflop= 1009;
  25.   cmcopie= 1010;
  26. type
  27.   TListboxRec = record
  28.     PS : PStringCollection;
  29.     Focused : Integer;
  30.     end;
  31. type
  32.   TMyApp = object(TApplication)
  33.     procedure InitMenuBar; virtual;
  34.     procedure LoadFont;
  35.     procedure saveasfont;
  36.     procedure Modif_Car;
  37.     procedure Inverse_car;
  38.     procedure Fill_car;
  39.     procedure clear_car;
  40.     procedure flip_car;
  41.     procedure flop_car;
  42.     procedure copie_car;
  43.     procedure HandleEvent(var Event: TEvent); virtual;
  44.   end;
  45. type charset = array[0..255,1..16] of byte;
  46. var  newcharset, oldcharset : charset;
  47.      fichier:file of charset;
  48.      char:array[1..16] of byte;
  49.      bingo:string;
  50. var
  51.   DataRecChar : record
  52.     Field1 : Word;
  53.     Field2 : Word;
  54.     Field3 : Word;
  55.     Field4 : Word;
  56.     Field5 : Word;
  57.     Field6 : Word;
  58.     Field7 : Word;
  59.     Field8 : Word;
  60.   end;
  61.  
  62. var
  63.   DataRec : record
  64.     Field1 : TListBoxRec;
  65.          end;
  66. var
  67.   MyApp: TMyApp;
  68.   Cartab :record {les categories}
  69.             Field1 : TListBoxRec;
  70.             end;
  71.   i:byte;
  72.   chaine:string;
  73. { -------------------- fonction misc . --------------------}
  74. procedure getoldcharset;
  75. var
  76.   b:byte;
  77.   w:word;
  78. begin
  79.   for b := 0 to 255 do begin
  80.     w := b * 32;
  81.     inline($FA);
  82.     PortW[$3C4] := $0402;
  83.     PortW[$3C4] := $0704;
  84.     PortW[$3CE] := $0204;
  85.     PortW[$3CE] := $0005;
  86.     PortW[$3CE] := $0006;
  87.     Move(Ptr($A000, w)^, oldcharset[b,1], 16);
  88.     PortW[$3C4] := $0302;
  89.     PortW[$3C4] := $0304;
  90.     PortW[$3CE] := $0004;
  91.     PortW[$3CE] := $1005;
  92.     PortW[$3CE] := $0E06;
  93.     inline($FB);
  94.   end;
  95. end;
  96.  
  97. procedure restoreoldcharset;
  98. var
  99.   b:byte;
  100.   w:word;
  101. begin
  102.   for b := 0 to 255 do begin
  103.     w := b * 32;
  104.     inline($FA);
  105.     PortW[$3C4] := $0402;
  106.     PortW[$3C4] := $0704;
  107.     PortW[$3CE] := $0204;
  108.     PortW[$3CE] := $0005;
  109.     PortW[$3CE] := $0006;
  110.     Move(oldcharset[b,1], Ptr($A000, w)^, 16);
  111.     PortW[$3C4] := $0302;
  112.     PortW[$3C4] := $0304;
  113.     PortW[$3CE] := $0004;
  114.     PortW[$3CE] := $1005;
  115.     PortW[$3CE] := $0E06;
  116.     inline($FB);
  117.   end;
  118. end;
  119.  
  120. procedure setasciichar(charnum : byte; var data);
  121. var
  122.    offset : Word;
  123. begin
  124.   offset := charNum * 32;
  125.   inline($FA);
  126.   PortW[$3C4] := $0402;
  127.   PortW[$3C4] := $0704;
  128.   PortW[$3CE] := $0204;
  129.   PortW[$3CE] := $0005;
  130.   PortW[$3CE] := $0006;
  131.   Move(data, Ptr($A000, offset)^, 16);
  132.   PortW[$3C4] := $0302;
  133.   PortW[$3C4] := $0304;
  134.   PortW[$3CE] := $0004;
  135.   PortW[$3CE] := $1005;
  136.   PortW[$3CE] := $0E06;
  137.   inline($FB);
  138. end;
  139. function bit_a_un(a,pos:byte):Boolean;
  140. BEGIN
  141.  if ((a shr pos) and 1)=1 then bit_a_un:=true
  142.     else bit_a_un:=false;
  143. END;
  144. procedure put_bit_a_un(var a:byte;pos:byte);
  145. BEGIN
  146.  a:=a or (1 shl pos);
  147. END;
  148. { ------------------ les boites dialogues --------------------- }
  149. function Ensenchar : PDialog;
  150. var
  151.   Dlg : PDialog;
  152.   R : TRect;
  153.   Control : PView;
  154. begin
  155. R.Assign(3, 2, 37, 12);
  156. New(Dlg, Init(R, 'Ensenble caractères'));
  157. Dlg^.Flags := Dlg^.Flags {and not wfClose};
  158.  
  159. R.Assign(1, 1, 33, 9);
  160. bingo:='';
  161. for i:=1 to 254 do
  162.      if (i<>13) and (i<>32) then
  163.         bingo:=bingo+chr(i);
  164. Control := New(PStaticText, Init(R, bingo));
  165. Dlg^.Insert(Control);
  166.  
  167. Dlg^.SelectNext(False);
  168. Ensenchar := Dlg;
  169. end;
  170. function MakeDialogC(titre:string) : PDialog;
  171. var
  172.   Dlg : PDialog;
  173.   R : TRect;
  174.   Control : PView;
  175.  
  176. begin
  177. R.Assign(10, 2, 45, 22);
  178. New(Dlg, Init(R, titre));
  179.  
  180. R.Assign(1, 1, 5, 16);
  181. Control := New(PCheckboxes, Init(R,
  182.   NewSItem('A',  NewSItem('b',  NewSItem('c ',  NewSItem('d',
  183.   NewSItem('e',
  184.   NewSItem('f',
  185.   NewSItem('i',
  186.   NewSItem('j',
  187.   NewSItem('k',
  188.   NewSItem('l',
  189.   NewSItem('o',
  190.   NewSItem('p',
  191.   NewSItem('k',
  192.   NewSItem('q',
  193.   NewSItem('x', Nil)))))))))))))))));
  194. Dlg^.Insert(Control);
  195.  
  196. R.Assign(5, 1, 10, 16);
  197. Control := New(PCheckboxes, Init(R, 
  198.   NewSItem('a',
  199.   NewSItem('a',
  200.   NewSItem('a',
  201.   NewSItem('a',
  202.   NewSItem('a',
  203.   NewSItem('a',
  204.   NewSItem('a',
  205.   NewSItem('a',
  206.   NewSItem('a',
  207.   NewSItem('a',
  208.   NewSItem('a',
  209.   NewSItem('a',
  210.   NewSItem('a',
  211.   NewSItem('a',
  212.   NewSItem('a', Nil)))))))))))))))));
  213. Dlg^.Insert(Control);
  214.  
  215. R.Assign(9, 1, 14, 16);
  216. Control := New(PCheckboxes, Init(R, 
  217.   NewSItem('b',
  218.   NewSItem('b',
  219.   NewSItem('b',
  220.   NewSItem('b',
  221.   NewSItem('b',
  222.   NewSItem('b',
  223.   NewSItem('b',
  224.   NewSItem('b',
  225.   NewSItem('b',
  226.   NewSItem('b',
  227.   NewSItem('b',
  228.   NewSItem('b',
  229.   NewSItem('b',
  230.   NewSItem('b',
  231.   NewSItem('b', Nil)))))))))))))))));
  232. Dlg^.Insert(Control);
  233.  
  234. R.Assign(13, 1, 18, 16);
  235. Control := New(PCheckboxes, Init(R, 
  236.   NewSItem('c',
  237.   NewSItem('c',
  238.   NewSItem('c',
  239.   NewSItem('c',
  240.   NewSItem('c',
  241.   NewSItem('c',
  242.   NewSItem('c',
  243.   NewSItem('c',
  244.   NewSItem('c',
  245.   NewSItem('c',
  246.   NewSItem('c',
  247.   NewSItem('c',
  248.   NewSItem('c',
  249.   NewSItem('c',
  250.   NewSItem('c', Nil)))))))))))))))));
  251. Dlg^.Insert(Control);
  252.  
  253. R.Assign(17, 1, 22, 16);
  254. Control := New(PCheckboxes, Init(R, 
  255.   NewSItem('d',
  256.   NewSItem('d',
  257.   NewSItem('d',
  258.   NewSItem('d',
  259.   NewSItem('d',
  260.   NewSItem('d',
  261.   NewSItem('d',
  262.   NewSItem('d',
  263.   NewSItem('d',
  264.   NewSItem('d',
  265.   NewSItem('d',
  266.   NewSItem('d',
  267.   NewSItem('d',
  268.   NewSItem('d',
  269.   NewSItem('d', Nil)))))))))))))))));
  270. Dlg^.Insert(Control);
  271.  
  272. R.Assign(21, 1, 26, 16);
  273. Control := New(PCheckboxes, Init(R, 
  274.   NewSItem('e',
  275.   NewSItem('e',
  276.   NewSItem('e',
  277.   NewSItem('e',
  278.   NewSItem('e',
  279.   NewSItem('e',
  280.   NewSItem('e',
  281.   NewSItem('e',
  282.   NewSItem('e',
  283.   NewSItem('e',
  284.   NewSItem('e',
  285.   NewSItem('e',
  286.   NewSItem('e',
  287.   NewSItem('e',
  288.   NewSItem('e', Nil)))))))))))))))));
  289. Dlg^.Insert(Control);
  290.  
  291. R.Assign(25, 1, 30, 16);
  292. Control := New(PCheckboxes, Init(R, 
  293.   NewSItem('f',
  294.   NewSItem('f',
  295.   NewSItem('f',
  296.   NewSItem('f',
  297.   NewSItem('f',
  298.   NewSItem('f',
  299.   NewSItem('f',
  300.   NewSItem('f',
  301.   NewSItem('f',
  302.   NewSItem('f',
  303.   NewSItem('f',
  304.   NewSItem('f',
  305.   NewSItem('f',
  306.   NewSItem('f',
  307.   NewSItem('f', Nil)))))))))))))))));
  308. Dlg^.Insert(Control);
  309.  
  310. R.Assign(29, 1, 34, 16);
  311. Control := New(PCheckboxes, Init(R,
  312.   NewSItem('g',
  313.   NewSItem('g',
  314.   NewSItem('g',
  315.   NewSItem('g',
  316.   NewSItem('g',
  317.   NewSItem('g',
  318.   NewSItem('g',
  319.   NewSItem('g',
  320.   NewSItem('g',
  321.   NewSItem('g',
  322.   NewSItem('g',
  323.   NewSItem('g',
  324.   NewSItem('g',
  325.   NewSItem('g',
  326.   NewSItem('g', Nil)))))))))))))))));
  327. Dlg^.Insert(Control);
  328.  
  329. R.Assign(3, 17, 13, 19);
  330. Control := New(PButton, Init(R, 'O~k~', cmOK, bfDefault));
  331. Dlg^.Insert(Control);
  332.  
  333. R.Assign(19, 17, 29, 19);
  334. Control := New(PButton, Init(R, 'C~a~ncel', cmCancel, bfDefault));
  335. Dlg^.Insert(Control);
  336.  
  337. Dlg^.SelectNext(False);
  338. MakeDialogc:= Dlg;
  339. end;
  340.  
  341. function MakeDialog : PDialog;
  342. var
  343.   Dlg : PDialog;
  344.   R : TRect;
  345.   Control : PView;
  346.  
  347. begin
  348. R.Assign(47, 1, 62, 22);
  349. New(Dlg, Init(R, ''));
  350.  
  351. R.Assign(11, 2, 12, 17);
  352. Control := New(PScrollBar, Init(R));
  353. Dlg^.Insert(Control);
  354.  
  355. R.Assign(3, 2, 11, 17);
  356. Control := New(PListBox, Init(R, 1, PScrollbar(Control)));
  357. Dlg^.Insert(Control);
  358.  
  359.   R.Assign(2, 1, 13, 2);
  360.   Dlg^.Insert(New(PLabel, Init(R, 'caracteres', Control)));
  361.  
  362. R.Assign(3, 18, 13, 20);
  363. Control := New(PButton, Init(R, 'O~k~', cmOK, bfDefault));
  364. Dlg^.Insert(Control);
  365.  
  366. Dlg^.SelectNext(False);
  367. MakeDialog := Dlg;
  368. end;
  369. {---------------------------------------}
  370. procedure TMyApp.LoadFont;
  371. var
  372.   R: TRect;
  373.   FileDialog: PFileDialog;
  374.   TheFile: FNameStr;
  375.   b:byte;
  376. const
  377.   FDOptions: Word = fdOKButton or fdOpenButton;
  378. begin
  379.   TheFile := '*.FNT';
  380.   New(FileDialog, Init(TheFile, 'Open file', '~F~ile name',
  381.     FDOptions, 1));
  382.   if ExecuteDialog(FileDialog, @TheFile) <> cmCancel then
  383.   begin
  384.    assign(Fichier,TheFile);
  385.    reset(Fichier);
  386.    read(Fichier,newcharset);
  387.    close(fichier);
  388.      for b := 0 to 255 do setasciichar(b,newcharset[b,1]);
  389.   end;
  390. end;
  391. procedure TMyApp.saveasFont;
  392. var
  393.   R: TRect;
  394.   FileDialog: PFileDialog;
  395.   TheFile: FNameStr;
  396. const
  397.   FDOptions: Word = fdOKButton or fdOpenButton;
  398. begin
  399.   TheFile := '*.FNT';
  400.   New(FileDialog, Init(TheFile, 'Save file', '~F~ile name',
  401.     FDOptions, 1));
  402.   if ExecuteDialog(FileDialog, @TheFile) <> cmCancel then
  403.   begin
  404.    assign(Fichier,TheFile);
  405.    rewrite(Fichier);
  406.    write(Fichier,newcharset);
  407.    close(fichier);
  408.   end;
  409. end;
  410.  
  411. procedure TMyApp.Modif_car;
  412. var j:byte;
  413.     k:word;
  414.     b:byte;
  415.     tempo:string;
  416. begin
  417. if Application^.ExecuteDialog(MakeDialog,@Cartab) = cmOk then
  418.  begin
  419.   with Datarecchar do
  420.    begin
  421.     field1:=0;field2:=0;field3:=0;field4:=0;field5:=0;field6:=0;field7:=0;field8:=0;
  422.     end;
  423.     for i:=1 to 16 do
  424.     begin
  425.     for j:=0 to 7 do
  426.     if ((newcharset[CarTab.Field1.focused+1][i] shl j) and 128) <> 0 then
  427.     begin
  428.      k:=1 shl (i-1) ;
  429.      with Datarecchar do
  430.      begin
  431.       case j of
  432.        0:field1:=field1 or k;
  433.        1:field2:=field2 or k;
  434.        2:field3:=field3 or k;
  435.        3:field4:=field4 or k;
  436.        4:field5:=field5 or k;
  437.        5:field6:=field6 or k;
  438.        6:field7:=field7 or k;
  439.        7:field8:=field8 or k;
  440.        end;
  441.       end;
  442.      end;
  443.  end;
  444.   str(CarTab.Field1.focused+1,tempo);
  445.   if Application^.ExecuteDialog(MakeDialogC('Caractere :'+tempo),@Datarecchar) = cmOk then
  446.   begin
  447.    for i:=1 to 16 do
  448.    begin
  449.    k:=0;
  450.    newcharset[CarTab.Field1.focused+1][i]:=0;
  451.    for j:=0 to 7 do
  452.    begin
  453.     with Datarecchar do begin
  454.       case j of
  455.        0:if ((field1 shr (i-1)) and 1)=1 then k:=128;
  456.        1:if ((field2 shr (i-1)) and 1)=1 then k:=64;
  457.        2:if ((field3 shr (i-1)) and 1)=1 then k:=32;
  458.        3:if ((field4 shr (i-1)) and 1)=1 then k:=16;
  459.        4:if ((field5 shr (i-1)) and 1)=1 then k:=8;
  460.        5:if ((field6 shr (i-1)) and 1)=1 then k:=4;
  461.        6:if ((field7 shr (i-1)) and 1)=1 then k:=2;
  462.        7:if ((field8 shr (i-1)) and 1)=1 then k:=1;
  463.        end;
  464.       newcharset[CarTab.Field1.focused+1][i]:=
  465.          newcharset[CarTab.Field1.focused+1][i] or k;
  466.      end;
  467.    end;
  468.   end;
  469.  end;
  470. end;
  471. setasciichar(CarTab.Field1.focused+1,newcharset[CarTab.Field1.focused+1,1]);
  472. end;
  473. procedure TMyApp.Inverse_car;
  474. var j:byte;
  475. begin
  476. if Application^.ExecuteDialog(MakeDialog,@Cartab) = cmOk then
  477.  begin
  478.   for j:=1 to 16 do
  479.   newcharset[CarTab.Field1.focused+1][j]:=
  480.           newcharset[CarTab.Field1.focused+1][j] xor 255;
  481.  setasciichar(CarTab.Field1.focused+1,newcharset[CarTab.Field1.focused+1,1]);
  482.  end;
  483. end;
  484. procedure TMyApp.Copie_car;
  485. var j:byte;
  486.     k:word;
  487. begin
  488. if Application^.ExecuteDialog(MakeDialog,@Cartab) = cmOk then
  489.  begin
  490.   k:=CarTab.Field1.focused+1;
  491.   if Application^.ExecuteDialog(MakeDialog,@Cartab) = cmOk then
  492.   begin
  493.   for j:=1 to 16 do
  494.   newcharset[CarTab.Field1.focused+1][j]:=newcharset[k][j];
  495.   end;
  496.  setasciichar(CarTab.Field1.focused+1,newcharset[CarTab.Field1.focused+1,1]);
  497.  end;
  498. end;
  499.  
  500. procedure TMyApp.Clear_car;
  501. var j:byte;
  502. begin
  503. if Application^.ExecuteDialog(MakeDialog,@Cartab) = cmOk then
  504.  begin
  505.   for j:=1 to 16 do
  506.   newcharset[CarTab.Field1.focused+1][j]:=0;
  507.  setasciichar(CarTab.Field1.focused+1,newcharset[CarTab.Field1.focused+1,1]);
  508.  end;
  509. end;
  510. procedure TMyApp.Fill_car;
  511. var j:byte;
  512. begin
  513. if Application^.ExecuteDialog(MakeDialog,@Cartab) = cmOk then
  514.  begin
  515.   for j:=1 to 16 do
  516.   newcharset[CarTab.Field1.focused+1][j]:=255;
  517.  setasciichar(CarTab.Field1.focused+1,newcharset[CarTab.Field1.focused+1,1]);
  518.  end;
  519. end;
  520. procedure TMyApp.flip_car;
  521. var j,k,tempo:byte;
  522. begin
  523. if Application^.ExecuteDialog(MakeDialog,@Cartab) = cmOk then
  524.  begin
  525.   for j:=1 to 16 do
  526.    begin
  527.     tempo:=0;
  528.     for k:=0 to 7 do
  529.      begin
  530.      if (bit_a_un(newcharset[CarTab.Field1.focused+1][j],k)) then
  531.       put_bit_a_un(tempo,7-k);
  532.      end;
  533.    newcharset[CarTab.Field1.focused+1][j]:=tempo;
  534.    end;
  535.  setasciichar(CarTab.Field1.focused+1,newcharset[CarTab.Field1.focused+1,1]);
  536.  end;
  537. end;
  538. procedure TMyApp.flop_car;
  539. var j,tempo:byte;
  540. begin
  541. if Application^.ExecuteDialog(MakeDialog,@Cartab) = cmOk then
  542.  begin
  543.   for j:=1 to 8 do
  544.   begin
  545.   tempo:=newcharset[CarTab.Field1.focused+1][j];
  546.   newcharset[CarTab.Field1.focused+1][j]:=newcharset[CarTab.Field1.focused+1][17-j];
  547.   newcharset[CarTab.Field1.focused+1][17-j]:=tempo;
  548.   end;
  549.  setasciichar(CarTab.Field1.focused+1,newcharset[CarTab.Field1.focused+1,1]);
  550.  end;
  551. end;
  552.  
  553. procedure TMyApp.HandleEvent(var Event: TEvent);
  554. begin
  555. TApplication.HandleEvent(Event);
  556. case Event.What of
  557.     evCommand:
  558.       case Event.Command of
  559.        cmabout:
  560.         messagebox('         Char Edit                charles vidal 1994      vidal@amertume.ufr-info-p7.ibp.fr'
  561.             ,nil,mfinformation);
  562.        cmModifier:Modif_car;
  563.        cmsave:saveasfont;
  564.        cmload:loadfont;
  565.        cmEnscar:
  566.        MyApp.execview(Ensenchar);
  567.        cmInverse:Inverse_car;
  568.        cmFill:Fill_car;
  569.        cmClear:Clear_car;
  570.        cmFlip:flip_car;
  571.        cmFlop:flop_car;
  572.        cmcopie:copie_car;
  573.       end;
  574.     end;
  575. ClearEvent(Event);
  576. end;
  577.  
  578. Procedure TMyApp.InitMenuBar;
  579. var
  580.   R : TRect;
  581.  
  582. begin
  583.   GetExtent(R);
  584.   R.B.Y := R.A.Y + 1;
  585.  
  586.   MenuBar := New(PMenuBar, Init(R, NewMenu(
  587.     NewSubMenu('#',hcNoContext,
  588.     NewMenu(
  589.       NewItem('About', '', kbNoKey, cmAbout, hcNoContext,
  590.       NewItem('Ensenble caracteres', '', kbNoKey, cmEnscar, hcNoContext,
  591.       nil))),
  592.     NewSubMenu('~F~ile',hcNoContext,
  593.     NewMenu(
  594.       NewItem('Load', '', kbNoKey, cmLoad, hcNoContext,
  595.       NewItem('save', '', kbNoKey, cmsave, hcNoContext,
  596.       NewItem('~Q~uitter', '', kbNoKey, cmQuit, hcNoContext,
  597.       nil)))),
  598.     NewItem('~M~odifier', '', kbNoKey, cmModifier, hcNoContext,
  599.     NewSubMenu('~E~ffect',hcNoContext,
  600.     NewMenu(
  601.       NewItem('Inverse', '', kbNoKey, cmInverse, hcNoContext,
  602.       NewItem('Fill', '', kbNoKey, cmFill, hcNoContext,
  603.       NewItem('Clear', '', kbNoKey, cmClear, hcNoContext,
  604.       NewItem('Flip', '', kbNoKey, cmFlip, hcNoContext,
  605.       NewItem('Flop', '', kbNoKey, cmFlop, hcNoContext,
  606.       NewItem('copie', '', kbNoKey, cmcopie, hcNoContext,
  607.     nil))))))),
  608.     nil)))))
  609.   ));
  610. end;
  611.  
  612. begin
  613.   getoldcharset;
  614.   newcharset:=oldcharset;
  615.   Cartab.field1.PS:=New(PstringCollection, Init(10,5));
  616.   bingo:='';
  617.   for i:=1 to 254 do
  618.      if (i<>13) and (i<>32) then
  619.         bingo:=bingo+chr(i);
  620.   for i:=0 to 255 do Begin
  621.                      str(i,chaine);
  622.                      Cartab.field1.PS^.insert(newstr(chr(i)+':'+chaine));
  623.                      End;
  624.   Cartab.field1.PS^.atfree(0);
  625.   MyApp.Init;
  626.   MyApp.Run;
  627.   MyApp.Done;
  628.   restoreoldcharset;
  629. end.
  630.